C--------------------------------------------------------------------------- 

C Program name: Windows test program.

C Author: Gareth Williams

C Description:

C Modification history : (Version), (Date), (Name), (Description).

C 1.0, 1st September 1991, G. Williams, First Version.

C 2.0, June 1992, G. Williams, Converted to SunPHIGS 2.0.

C----------------------------------------------------------------------------

       PROGRAM windtest
       INTEGER minid, maxid, lampid
       INTEGER lamplist(1)
       INTEGER grey, green, black, white
       REAL pos(2), size(2)
       LOGICAL docolour
       INTEGER ptkf_stringtoint
       LOGICAL ptkf_readphinterscript

       include './sunphigs77.h'
       
         implicit undefined (P, p, E, e)

C colour or monochrome
       docolour = .TRUE.

C     open PHIGS 
         print *,('Demonstrating the windows module of the 
& PHIGS Toolkit...')
         print *,('Opening SunPHIGS...')

         call popph(6, 0)
 
C     create the workstation type (either tool or canvas) 
              
C     open the workstation 
       
       if (ptkf_readphinterscript('../../scripts/openws.scr', 0, 0) .eq.
& .FALSE.) then     
         goto 30
       endif

       call psdus(1, PWAITD, PNIVE)
       
C     initialise hashtables 
       
       minid = 1
       maxid = 50
       call ptkf_inithashtables()
       call ptkf_createhashtable('structureid', minid, maxid)
       call ptkf_createhashtable('topologyid', minid, maxid)
       call ptkf_createhashtable('label', minid, maxid)
       call ptkf_createhashtable('colourindex', 1, 50)
       call ptkf_createhashtable('viewindex', 1, 50)
       call ptkf_createhashtable('name', 1, 50)
              
       if (docolour .eq. .TRUE.) then
         call ptkf_setcolourrep(1, 'black')
         call ptkf_setcolourrep(1, 'white')
         call ptkf_setcolourrep(1, 'grey')
         call ptkf_setcolourrep(1, 'green')
         call ptkf_setcolourrep(1, 'red')
         call ptkf_setcolourrep(1, 'blue')
       endif

       if (ptkf_readphinterscript('../../scripts/lamp.scr', 0, 0) .eq.
& .TRUE.) then
         call ptkf_point(0.5, 0.5, pos)
         call ptkf_point(0.6, 0.6, size)     
         call ptkf_createwindow(1, 1, size, pos, 'lamp window')

         if (docolour .eq. .TRUE.) then
           green = ptkf_stringtoint('colourindex', 'green')
           grey = ptkf_stringtoint('colourindex', 'grey')
           white = ptkf_stringtoint('colourindex', 'white')
           black = ptkf_stringtoint('colourindex', 'black')
           call ptkf_setwindowattrs(1, PFONTTRIPLEX, black,
& green, grey, green, white, black)
           call ptkf_setbackgroundcolourind(1, grey)
         endif

         lampid = ptkf_stringtoint('structureid', 'lamp')
         call ptkf_posttowindow(1, lampid)

         lamplist(1) = lampid
         call ptkf_setcameraworld(1, 1, lamplist)
         call ptkf_setcameraprojtype(1, PPERS)
         call ptkf_postwindow(1)
       
         call ptkf_point(0.1, 0.9, pos)
         call ptkf_seticonposition(1, pos)
         call prst(1, PALWAY)
       
         call options()
       endif

 30    print *,('Closing PHIGS...')
       call pclwk(1)
       call pclph()

       STOP
       END
       
C--------------------------------------------------------------------------
       
      SUBROUTINE init_input()
C     Initializes two locators, one in sample mode, 
C     and one in event mode. 
       CHARACTER*80 lrec(10)
       CHARACTER*20 str(2)
       INTEGER ia(2)
       INTEGER la(2)
       REAL ra(2)
       REAL ea(4)
       INTEGER err
       REAL devx, devy

       include './sunphigs77.h'

       implicit undefined (P, p, E, e)
       
       call pslcm(1, 1, PREQU, PECHO)
       call pslcm(1, 4, PREQU, PECHO)
       
       call ptkf_inqmaxdevicecoords(1, devx, devy)
       
       call ptkf_limit(0.0, devx, 0.0, devy, ea)

       call pprec(0, ia, 0, ra, 0, la, str, 10, err, ldr, lrec)

       call pinlc(1, 1, 0, 0.5, 0.5, 1, ea(1), ea(2), ea(3), ea(4),
& ldr, lrec)
       call pinlc(1, 4, 0, 0.5, 0.5, 1, ea(1), ea(2), ea(3), ea(4),
& ldr, lrec)

       call pslcm(1, 1, PEVENT, PECHO)
       call pslcm(1, 4, PSAMPL, PECHO)

       RETURN
       END
       
C--------------------------------------------------------------------------
       
       SUBROUTINE camerainterface()
       INTEGER wsid, indev, viewindex, err
C Event input data. 
       INTEGER class
       REAL pos(2)
       REAL lims(6)
       REAL defcampos(3), campos(3)
       REAL zorg

       include './sunphigs77.h'
    
       implicit undefined (P, p, E, e)
       
       call init_input()

C Initialise input devices. 
       call ptkf_inqcameralimits(1, lims, err)
       call ptkf_inqcameraposition(1, defcampos, err)
       zorg = lims(5) + ((lims(6) - lims(5)) / 2.0)
 20    call psmlc(1, 4, viewindex, pos(1), pos(2))
       campos(1) = lims(1) + (lims(2) - lims(1)) * pos(1)
       campos(2) = lims(3) + (lims(4) - lims(3)) * pos(2)
       campos(3) = zorg + ((sin(3.142 * pos(1)) * sin(3.142 * pos(2)))
& * (defcampos(3) - zorg))
       call ptkf_setcameraposition(1, campos)
       call puwk(1, PPERFO)
       call pwait(0.25, wsid, class, indev)
C See if left button pressed. 
       if (class .ne. PLOCAT) then
         goto 20
       endif

       call pslcm(1, 1, PREQU, PECHO)
       call pslcm(1, 4, PREQU, PECHO)

       RETURN
       END
       
C--------------------------------------------------------------------------
         
         SUBROUTINE options()
         CHARACTER*20 commandstr
         INTEGER lencom
         LOGICAL quit
         REAL pos(2), size(2)
         REAL echoarea(4)
         REAL height
         INTEGER bancol, titlecol
         REAL ptkf_readfloat
         INTEGER ptkf_readint

         include './sunphigs77.h'
         include './sunptk77.h'

         implicit undefined (P, p, E, e)
         
         quit = .FALSE.
         call ptkf_limit(0.0, 0.25, 0.0, 0.01, echoarea)
 10      call ptkf_readstring(1, 'camera', 
& 'Input command (default = camera)>', echoarea, 20, commandstr, 
& lencom)
         if (commandstr(1:lencom) .eq. 'camera') then
           call camerainterface()
         else if (commandstr(1:lencom) .eq. 'position') then
           pos(1) = ptkf_readfloat(1, 0.5, 'Input position, x (0.5) >', 
& echoarea)
           pos(2) = ptkf_readfloat(1, 0.5, 'Input position, y (0.5) >', 
& echoarea)
           call ptkf_setwindowposition(1, pos)
         else if (commandstr(1:lencom) .eq. 'size') then
           size(1) = ptkf_readfloat(1, 0.5, 'Input size, x (0.5) >', 
& echoarea)
           size(2) = ptkf_readfloat(1, 0.5, 'Input size, y (0.5) >', 
& echoarea)
           call ptkf_setwindowsize(1, size)
         else if (commandstr(1:lencom) .eq. 'iconposition') then
           pos(1) = ptkf_readfloat(1, 0.5, 'Input icon position, 
& x (0.5) >', echoarea)
           pos(2) = ptkf_readfloat(1, 0.5, 'Input icon position, 
& y (0.5) >', echoarea)
           call ptkf_seticonposition(1, pos)
         else if (commandstr(1:lencom) .eq. 'iconsize') then
           size(1) = ptkf_readfloat(1, 0.1, 'Input icon size, 
& x (0.1) >', echoarea)
           size(2) = ptkf_readfloat(1, 0.1, 'Input icon size, 
& y (0.1) >', echoarea)
           call ptkf_seticonsize(1, size)
         else if (commandstr(1:lencom) .eq. 'framesize') then
           size(1) = ptkf_readfloat(1, 0.01, 'Input frame size,
& x (0.01) >', echoarea)
           size(2) = ptkf_readfloat(1, 0.01, 'Input frame size, 
& y (0.01) >', echoarea)
           call ptkf_setframesize(1, size)
         else if (commandstr(1:lencom) .eq. 'open') then
           call ptkf_openwindow(1)
         else if (commandstr(1:lencom) .eq. 'close') then
           call ptkf_closewindow(1)
         else if (commandstr(1:lencom) .eq. 'front') then
           call ptkf_frontwindow(1)
         else if (commandstr(1:lencom) .eq. 'back') then
           call ptkf_backwindow(1)
         else if (commandstr(1:lencom) .eq. 'bannerheight') then
           height = ptkf_readfloat(1, 0.01, 'Input banner height >', 
& echoarea)
           call ptkf_setbannerheight(1, height)
         else if (commandstr(1:lencom) .eq. 'bannercolours') then
           bancol = ptkf_readint(1, 0, 'Input banner colour index >',
& echoarea)
           titlecol = ptkf_readint(1, 1, 
& 'Input title string colour index >', echoarea)
           call ptkf_setbannercolours(1, bancol, titlecol)
         else if (commandstr(1:lencom) .eq. 'phinter') then
           call ptkf_callphinter()
         else if (commandstr(1:lencom) .eq. 'quit') then
           quit = .TRUE.
         else
           print *,('Command unknown')    
         endif

         call prst(1, PALWAY)

         if (quit .eq. .FALSE.) then
           goto 10            
         endif
            
         RETURN
         END

C--------------------------------------------------------------------------
                   
C     end of windtest.f
